home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Programmer Power Tools
/
Programmer Power Tools.iso
/
microcrn
/
issue_49.arc
/
GENSORT.ARC
/
GENSRT.M2
< prev
Wrap
Text File
|
1989-07-11
|
10KB
|
323 lines
(* Micro Cornucopia Magazine Issue #49
Units and Modules Figure 1 - Generic sort routines *)
unit GenSort;
(*
Author: Michael S. Hunt Date: June 1, 1989
This source code is release into the public domain.
*)
interface
const MAX_KEYS = 16;
MAX_SRTS = 8;
MAX_MSG = 10;
MAX_DATA_LEN = 32768;
MSG_SIZE = 40;
srtMsg : array[1..MAX_MSG] of string[MSG_SIZE] =
('successful operation',
'zero records left to retrieve ',
'routines called in incorrect order',
'maximum sorts exceeded',
'too many keys',
'invalid sort id',
'not valid sort',
'sort in release state',
'sort in retrieve state',
'sort done');
GenSrtErr_NM = 0; (* successful operation *)
GenSrtErr_ZR = 1; (* zero records left to retrieve *)
GenSrtErr_ICO = 2; (* routines called in incorrect order *)
GenSrtErr_MSE = 3; (* maximum sorts exceeded *)
GenSrtErr_TMK = 4; (* too many keys *)
GenSrtErr_ISI = 5; (* invalid sort id *)
GenSrtSt_NV = 6; (* not valid sort *)
GenSrtSt_REL = 7; (* sort in release state *)
GenSrtSt_RET = 8; (* sort in retrieve state *)
GenSrtSt_DONE = 9; (* sort done *)
GenSrtDType_BL = 1; (* type boolean *)
GenSrtDType_B = 2; (* type byte *)
GenSrtDType_W = 3; (* type word *)
GenSrtDType_C = 4; (* type char 1 byte *)
GenSrtDType_ST = 5; (* type string 1..255 bytes *)
GenSrtOrder_A = 0; (* ascending sort order *)
GenSrtOrder_D = 1; (* descending sort order *)
type KeyRec = record
dataType, order, offset, length : word
end;
Keyarr = array[1..MAX_KEYS*4+1] of word;
Bytes = array[1..MAX_DATA_LEN] of byte;
Chars = array[1..MAX_DATA_LEN] of char;
PtrRec = record
ofs, seg : word
end;
SrtKeyRec = record
nbrKeys : word;
key : array[1..MAX_KEYS] of KeyRec
end;
SrtStatRec = record
nbrKeys, dataLen, keyLen, srtState : word;
nbrRec : longint
end;
SrtStr = string[80];
var srtKeyArr : array[1..MAX_SRTS] of SrtKeyRec;
srtStatArr : array[1..MAX_SRTS] of SrtStatRec;
procedure GenSrtBegin (var key; dataLen : word; var srtId : word;
var srtStatus : word);
function GenSrtBeginF (var key; dataLen : word; var srtId : word) : word;
procedure GenSrtRelease (var rec; srtId : word; var srtStatus : word);
function GenSrtReleaseF (var rec; srtId : word) : word;
procedure GenSrtDoSrt (srtId : word; var srtStatus :word);
function GenSrtDoSrtF (srtId : word) : word;
procedure GenSrtRetrieve (var rec; srtId : word; var srtStatus : word);
function GenSrtRetrieveF (var rec; srtId : word) : word;
procedure GenSrtEnd (srtId : word; var srtStatus : word);
function GenSrtEndF (srtId : word) : word;
procedure GenSrtStat (var srtStatus : SrtStatRec; srtId :word);
procedure GenSrtMsg (srtStatus : word; var srtString : SrtStr);
implementation
uses GenBinTree;
var srtRootArr : array[1..MAX_SRTS] of treePtr;
j : word;
function NextSrtId : word;
var j : word;
done : boolean;
begin
j := 1;
NextSrtId := 0;
done := false;
repeat
if srtStatArr[j].srtState = GenSrtSt_NV then
begin
NextSrtId := j;
done := true;
srtStatArr[j].srtState := GenSrtSt_REL
end;
j := j+1
until (j > MAX_SRTS) OR (done)
end;
function ValidSrtId(srtId : word) : boolean;
begin
if (srtId <= MAX_SRTS) AND (srtId > 0) then
if srtStatArr[srtId].srtState <> GenSrtSt_NV then
ValidSrtId := true
else
ValidSrtId := false
end;
procedure ClearSrtId(srtId : word);
begin
if (srtId <= MAX_SRTS) AND (srtId > 0) then
srtStatArr[srtId].srtState := GenSrtSt_NV
end;
procedure Descend(var rec; recLen : word);
var j : word;
begin
for j := 1 to recLen do
begin
Bytes(rec)[j] := $FF xor Bytes(rec)[j]
end
end;
procedure GenSrtBegin (var key; dataLen : word; var srtId : word;
var srtStatus : word);
begin
srtStatus := GenSrtBeginF(key, dataLen, srtID)
end;
function GenSrtBeginF (var key; dataLen : word; var srtId : word) : word;
var j, k : word;
begin
srtId := NextSrtId;
if srtId > 0 THEN
begin
srtKeyArr[srtId].nbrkeys := KeyArr(key)[1];
if srtKeyArr[srtId].nbrkeys <= MAX_KEYS then
begin
for j := 1 to srtKeyArr[srtId].nbrKeys do
begin
srtKeyArr[srtId].key[j].dataType := KeyArr(key)[j*4-2];
srtKeyArr[srtId].key[j].order := KeyArr(key)[j*4-1];
srtKeyArr[srtId].key[j].offset := KeyArr(key)[j*4];
srtKeyArr[srtId].key[j].length := KeyArr(key)[j*4+1]
end;
srtStatArr[srtId].nbrKeys := srtKeyArr[srtId].nbrKeys;
srtStatArr[srtId].dataLen := dataLen;
srtStatArr[srtId].keyLen := 0;
for j := 1 to srtKeyArr[srtId].nbrKeys do
srtStatArr[srtId].keyLen := srtStatArr[srtId].keyLen
+ srtKeyArr[srtId].key[j].length;
srtStatArr[srtId].nbrRec := 0;
srtStatArr[srtId].srtState := GenSrtSt_REL;
GenSrtBeginF := GenSrtErr_NM
end
else
begin
ClearSrtId(srtId);
GenSrtBeginF := GenSrtErr_TMK
end
end
else
GenSrtBeginF := GenSrtErr_MSE
end;
procedure GenSrtRelease (var rec; srtId : word; var srtStatus : word);
begin
srtStatus := GenSrtReleaseF(rec, srtId)
end;
function GenSrtReleaseF (var rec; srtId : word) : word;
var data, key, tkey : dataPtr;
j, k : word;
begin
if ValidSrtId(srtId) then
begin
k := 1;
GetMem(key, srtStatArr[srtId].keyLen);
GetMem(data, srtStatArr[srtId].dataLen);
tkey := key;
for j := 1 to srtKeyArr[srtId].nbrKeys do
begin
if (srtKeyArr[srtId].key[j].dataType = GenSrtDType_BL) then
begin
tkey^ := Chars(rec)[srtKeyArr[srtId].key[j].offset];
Inc(PtrRec(tkey).ofs,1)
end
else if (srtKeyArr[srtId].key[j].dataType = GenSrtDType_B) then
begin
tkey^ := Chars(rec)[srtKeyArr[srtId].key[j].offset];
Inc(PtrRec(tkey).ofs,1)
end
else if (srtKeyArr[srtId].key[j].dataType = GenSrtDType_W) then
begin
tkey^ := Chars(rec)[srtKeyArr[srtId].key[j].offset+1];
Inc(PtrRec(tkey).ofs,1);
tkey^ := Chars(rec)[srtKeyArr[srtId].key[j].offset];
Inc(PtrRec(tkey).ofs,1)
end
else if (srtKeyArr[srtId].key[j].dataType = GenSrtDType_C) then
begin
tkey^ := Chars(rec)[srtKeyArr[srtId].key[j].offset];
Inc(PtrRec(tkey).ofs,1)
end
else if (srtKeyArr[srtId].key[j].dataType = GenSrtDType_ST) then
begin
for k := 1 to srtKeyArr[srtId].key[j].length do
begin
tkey^ := Chars(rec)[srtKeyArr[srtId].key[j].offset+k];
Inc(PtrRec(tkey).ofs,1)
end
end;
if (srtKeyArr[srtId].key[j].order <> GenSrtOrder_A) then
begin
Descend(key^, srtKeyArr[srtId].key[j].length)
end
end;
Move(rec, data^, srtStatArr[srtId].dataLen);
GenBinInsert (srtRootArr[srtId], key, srtStatArr[srtId].keyLen,
data, srtStatArr[srtId].dataLen);
srtStatArr[srtId].nbrRec := srtStatArr[srtId].nbrRec + 1;
end
else
GenSrtReleaseF := GenSrtErr_ISI
end;
procedure GenSrtDoSrt (srtId : word; var srtStatus :word);
begin
srtStatus := GenSrtDoSrtF(srtId)
end;
function GenSrtDoSrtF (srtId : word) : word;
begin
if ValidSrtId(srtId) then
begin
srtStatArr[srtId].srtState := GenSrtSt_RET;
GenSrtDoSrtF := GenSrtErr_NM;
end
else
GenSrtDoSrtF := GenSrtErr_ISI
end;
procedure GenSrtRetrieve (var rec; srtId : word; var srtStatus : word);
begin
srtStatus := GenSrtRetrieveF(rec, srtId)
end;
function GenSrtRetrieveF (var rec; srtId : word) : word;
var d, k : dataPtr;
dlen, klen : word;
begin
if ValidSrtId(srtId) then
if srtStatArr[srtId].srtState = GenSrtSt_RET then
if srtStatArr[srtId].nbrRec > 0 then
begin
GenBinRetDelSmRec(srtRootArr[srtId], k, klen, d, dlen);
Move(d^, rec, dlen);
srtStatArr[srtId].nbrRec := srtStatArr[srtId].nbrRec - 1;
GenSrtRetrieveF := GenSrtErr_NM;
end
else
GenSrtretrieveF := GenSrtErr_ZR
else
GenSrtRetrieveF := GenSrtErr_ICO
else
GenSrtRetrieveF := GenSrtErr_ISI
end;
procedure GenSrtEnd (srtId : word; var srtStatus : word);
begin
srtStatus := GenSrtEndF(srtId)
end;
function GenSrtEndF (srtId : word) : word;
var d, k : dataPtr;
j, dlen, klen : word;
begin
if ValidSrtId(srtId) then
begin
for j := 1 to srtStatArr[srtId].nbrRec do
GenBinRetDelSmRec(srtRootArr[srtId], d, dlen, k, klen);
srtStatArr[srtId].nbrRec := 0;
srtStatArr[srtId].srtState := GenSrtSt_NV
end
else
GenSrtEndF := GenSrtErr_ISI
end;
procedure GenSrtStat (var srtStatus : SrtStatRec; srtId :word);
begin
srtStatus := srtStatArr[srtId]
end;
procedure GenSrtMsg (srtStatus : word; var srtString : SrtStr);
begin
if srtStatus <= MAX_MSG then
srtString := SrtMsg[srtStatus + 1]
end;
begin
for j := 1 to MAX_SRTS do
srtStatArr[j].srtState := GenSrtSt_NV;
end.